home *** CD-ROM | disk | FTP | other *** search
/ SPACE 1 / SPACE - Library 1 - Volume 1.iso / misc~1 / 201 / card / card.pas next >
Encoding:
Pascal/Delphi Source File  |  1988-05-08  |  15.8 KB  |  650 lines
  1. Program Card_Maker;
  2.  
  3. Const
  4.     {$I Gemconst.Pas}
  5.  
  6. Type
  7.     Col1 = Array [1..128] Of String[80];
  8.     Col2 = Array [1..128] Of String[80];
  9.     Col3 = Array [1..128] Of String[80];
  10.     Col4 = Array [1..128] Of String[80];
  11.     Col5 = Array [1..128] Of String[80];
  12.     OUT  = Array [1..5] of Boolean;
  13.     {$I Gemtype.Pas}
  14.  
  15. Var Run,MF,LI,Ci,RS,
  16.     MRF         :Boolean;
  17.     Command,
  18.     Title       :String[80];
  19.     H,TH,
  20.     CNum,
  21.     Cl1,Cl2,Cl3,
  22.     Cl4,Cl5,
  23.     Dummy,TST,
  24.     IST         :Integer;
  25.     Sauto,Ce    :Char;
  26.     Data1       :Col1;
  27.     Data2       :Col2;
  28.     Data3       :Col3;
  29.     Data4       :Col4;
  30.     Data5       :Col5;
  31.     t           :1..5;
  32.     C1,C2,C3,
  33.     C4,C5       :1..100;
  34.     Flag        :out;
  35.     s           :1..200;
  36.     cf          :Integer;
  37.     XStyle      :Char;
  38.     Style       :Char;
  39.     name        :String[80];
  40.     Fv          :File of text;
  41.  
  42. {$I Gemsubs.Pas}
  43. {$I Screen.Pas}
  44.  
  45. Procedure GRInit;
  46.  
  47. Begin
  48.    s:=8;
  49.    TST:=$00;
  50.    IST:=$00;
  51.    Mf:=False;
  52.    LI:=False;
  53.    Ci:=False;
  54.    cf:=2;
  55.    Mrf:=false;
  56. End;
  57.  
  58. Procedure TClean;
  59.  
  60. Begin
  61.    NormVideo;
  62.    Gotoxy(24,1);
  63. Write('                                                                     ');
  64. Write('           ');
  65. End;
  66.  
  67. Procedure Clean;
  68.  
  69. Begin
  70.    InverseVideo;
  71.    Gotoxy(24,1);
  72. Write('                                                                     ');
  73. Write('       ');
  74. End;
  75.  
  76. Procedure Get_Command;
  77.  
  78. Begin
  79.    Clean;
  80.    InverseVideo;
  81.    Gotoxy(24,5);
  82. Write('                                                                     ');
  83. Write('       ');
  84.    Gotoxy(24,25);
  85.    Write('Text ',Xstyle);
  86.    Write(' - Title ',style);
  87.    If (Mf<>false) or (Mrf<>false) Then Write(' Frame');
  88.    If (LI<>false) Then Write(' Line');
  89.    If (Flag[1]=true) Then write(' 1');
  90.    If (Flag[2]=true) Then write(' 2');
  91.    If (Flag[3]=true) Then write(' 3');
  92.    If (Flag[4]=true) Then write(' 4');
  93.    If (Flag[5]=true) Then write(' 5');
  94.    Write(' Tl=',H);
  95.    Write(' Tx=',th);
  96.    Write(' V 1.1');
  97.    Gotoxy(24,1);
  98.    Write('Command>');
  99.    CursOn;
  100.    Readln(Command);
  101.    InverseVideo;
  102. End;
  103.  
  104. Procedure text_Height ( height : integer );
  105.  
  106. Type Ctrl_Parms         = Array [ 0..11 ] of integer;
  107.      Int_in_Parms       = Array [ 0..15 ] of integer;
  108.      Int_Out_Parms      = Array [ 0..45 ] of integer;
  109.      Pts_in_Parms       = Array [ 0..11 ] of integer;
  110.      Pts_Out_Parms      = Array [ 0..11 ] of integer;
  111.  
  112. Var
  113.    Control      :Ctrl_Parms;
  114.    int_in       :Int_in_Parms;
  115.    int_out      :Int_out_parms;
  116.    pts_in       :Pts_in_Parms;
  117.    pts_out      :Pts_Out_Parms;
  118.  
  119. Procedure VDI_Call( cmd, sub_cmd, nints, npts : Integer;
  120.     Var ctrl:ctrl_parms;
  121.     Var int_in:Int_in_Parms; Var int_out:int_out_parms;
  122.     Var pts_in:pts_in_parms; Var pts_out:pts_out_parms;
  123.     translate :Boolean );
  124.   External;
  125.  
  126. Begin
  127.    pts_in[0]:= 0;
  128.    pts_in[1]:= height;
  129.    VDI_Call( 12,0,0,2, control, int_in, int_out, pts_in, pts_out, false );
  130. End;
  131.  
  132. Procedure Set_Title;
  133.  
  134. Begin
  135.    Clean;
  136.    InverseVideo;
  137.    Gotoxy(24,1);
  138.    Write('Enter size of title in pixels :');
  139.    InverseVideo;
  140.    Readln(H);
  141.    Clean;
  142.    InverseVideo;
  143.    Gotoxy(24,1);
  144.    Write('Enter title :');
  145.    InverseVideo;
  146.    Readln(title);
  147. End;
  148.  
  149. Procedure Set_Colomns;
  150.  
  151. Begin
  152.    Clean;
  153.    InverseVideo;
  154.    Gotoxy(24,1);
  155.    Write('How many colomns will you have? ( Max = 5 ) :');
  156.    InverseVideo;
  157.    Readln(CNum);
  158.    Clean;
  159.    InverseVideo;
  160.    Gotoxy(24,1);
  161.    Write('Automatic setting (y/n) ? :');
  162.    InverseVideo;
  163.    Readln(SAuto);
  164.    If (SAuto='n') Or (Sauto='N') Then
  165.       Begin
  166.          Clean;
  167.          InverseVideo;
  168.          Gotoxy(24,1);
  169.          Write('Enter colomn length #1 :');
  170.          InverseVideo;
  171.          Readln(CL1);
  172.          Clean;
  173.          InverseVideo;
  174.          Gotoxy(24,1);
  175.          Write('Enter colomn length #2 :');
  176.          InverseVideo;
  177.          Readln(CL2);
  178.          Clean;
  179.          InverseVideo;
  180.          Gotoxy(24,1);
  181.          Write('Enter colomn length #3 :');
  182.          InverseVideo;
  183.          Readln(CL3);
  184.          Clean;
  185.          InverseVideo;
  186.          Gotoxy(24,1);
  187.          Write('Enter colomn length #4 :');
  188.          InverseVideo;
  189.          Readln(CL4);
  190.          Clean;
  191.          InverseVideo;
  192.          Gotoxy(24,1);
  193.          Write('Enter colomn length #5 :');
  194.          InverseVideo;
  195.          Readln(CL5);
  196.       End
  197.    Else
  198.       Begin
  199.          Cl1:=trunc((80/Cnum));
  200.          Cl2:=trunc((80/Cnum));
  201.          Cl3:=trunc((80/Cnum));
  202.          Cl4:=trunc((80/Cnum));
  203.          Cl5:=trunc((80/Cnum));
  204.       End;
  205. End;
  206.  
  207. Procedure Enter_Data;
  208.  
  209. Var which       :Integer;
  210.     Sentence    :String[80];
  211.     j,k         :1..129;
  212.  
  213. Begin
  214.    Clean;
  215.    InverseVideo;
  216.    Gotoxy(24,1);
  217.    Write('Start entering at colomn #');
  218.    inverseVIdeo;
  219.    readln(which);
  220.    If (Which<1) then which:=1;
  221.    If (Which>5) Then which:=5;
  222.    Sentence:='????';
  223.    Clean;
  224.    If (flag[which]=true) And (which=1) Then
  225.       begin
  226.          Gotoxy(24,1);
  227.          Write('Start at row number :');
  228.          Readln(k);
  229.          If (k>C1) or (k>128) or (k<1) Then k:=C1;
  230.       End;
  231.    If (flag[which]=true) And (which=2) Then
  232.       begin
  233.          Gotoxy(24,1);
  234.          Write('Start at row number :');
  235.          Readln(k);
  236.          If (k>C2) or (k>128) or (k<1) Then k:=C2;
  237.       End;
  238.    If (flag[which]=true) And (which=3) Then
  239.       begin
  240.          Gotoxy(24,1);
  241.          Write('Start at row number :');
  242.          Readln(k);
  243.          If (k>C3) or (k>128) or (k<1) Then k:=C3;
  244.       End;
  245.    If (flag[which]=true) And (which=4) Then
  246.       begin
  247.          Gotoxy(24,1);
  248.          Write('Start at row number :');
  249.          Readln(k);
  250.          If (k>c4) or (k>128) or (k<1) Then k:=C4;
  251.       End;
  252.    If (flag[which]=true) And (which=5) Then
  253.       begin
  254.          Gotoxy(24,1);
  255.          Write('Start at row number :');
  256.          Readln(k);
  257.          If (k>c5) or (k>128) or (k<1) Then k:=C5;
  258.       End;
  259.    If (flag[which]=false) Then k:=1;
  260.    j:=k;
  261.    Flag[which]:=true;
  262.    Repeat
  263.       Clean;
  264.       InverseVideo;
  265.       If which=1 Then
  266.          Begin
  267.             Gotoxy(24,(4+CL1));
  268.             Writeln('<');
  269.          End;
  270.       If which=2 Then
  271.          Begin
  272.             Gotoxy(24,(4+CL2));
  273.             Writeln('<');
  274.          End;
  275.       If which=3 Then
  276.          Begin
  277.             Gotoxy(24,(4+CL3));
  278.             Writeln('<');
  279.          End;
  280.       If which=4 Then
  281.          Begin
  282.             Gotoxy(24,(4+CL4));
  283.             Writeln('<');
  284.          End;
  285.       If which=5 Then
  286.          Begin
  287.             Gotoxy(24,(4+CL5));
  288.             Writeln('<');
  289.          End;
  290.       Gotoxy(24,1);
  291.       Write('#',j,' >');
  292.       InverseVideo;
  293.       Readln(sentence);
  294.       If (which = 1) and (Length(sentence)>Cl1) then
  295.          Begin
  296.             Clean;
  297.             InverseVideo;
  298.             Gotoxy(24,1);
  299.             Write('#',j,' >');
  300.             InverseVideo;
  301.             Readln(sentence);
  302.          End;
  303.       if (which = 2) and (Length(sentence)>Cl2) then
  304.          Begin
  305.             Clean;
  306.             InverseVideo;
  307.             Gotoxy(24,1);
  308.             Write('#',j,' >');
  309.             InverseVideo;
  310.             Readln(sentence);
  311.          End;
  312.       if (which = 3) and (Length(sentence)>Cl3) then
  313.          Begin
  314.             Clean;
  315.             InverseVideo;
  316.             Gotoxy(24,1);
  317.             Write('#',j,' >');
  318.             InverseVideo;
  319.             Readln(sentence);
  320.          End;
  321.       if (which = 4) and (Length(sentence)>Cl4) then
  322.          Begin
  323.             Clean;
  324.             InverseVideo;
  325.             Gotoxy(24,1);
  326.             Write('#',j,' >');
  327.             InverseVideo;
  328.             Readln(sentence);
  329.          End;
  330.       if (which = 5) and (Length(sentence)>Cl5) then
  331.          Begin
  332.             Clean;
  333.             InverseVideo;
  334.             Gotoxy(24,1);
  335.             Write('#',j,' >');
  336.             InverseVideo;
  337.             Readln(sentence);
  338.          End;
  339.       j:=j+1;
  340.       If j>128 Then j:=128;
  341.       If (sentence<>'Stop') then
  342.       begin
  343.       if (which=1) Then Data1[j]:=sentence;
  344.       if (which=2) Then Data2[j]:=sentence;
  345.       if (which=3) Then Data3[j]:=sentence;
  346.       if (which=4) Then Data4[j]:=sentence;
  347.       if (which=5) Then Data5[j]:=sentence;
  348.       end;
  349.    Until sentence='Stop';
  350.       if (which=1) Then C1:=j;
  351.       if (which=2) Then C2:=j;
  352.       if (which=3) Then C3:=j;
  353.       if (which=4) Then C4:=j;
  354.       if (which=5) Then C5:=j;
  355. End;
  356.  
  357. Procedure Set_Text;
  358.  
  359. Begin
  360.    Clean;
  361.    InverseVideo;
  362.    Gotoxy(24,1);
  363.    Write('Enter text size :');
  364.    InverseVideo;
  365.    Readln(TH);
  366. End;
  367.  
  368. Procedure Set_S;
  369.  
  370. Begin
  371.    Clean;
  372.    InverseVideo;
  373.    Gotoxy(24,1);
  374.    Write('Enter spacing ( in pixels, max = 200) :');
  375.    InverseVideo;
  376.    Readln(s);
  377.    While (S>200) or (S<1) Do
  378.       Begin
  379.          Clean;
  380.          InverseVideo;
  381.          Gotoxy(24,1);
  382.          Write('Enter spacing ( in pixels, max = 200) :');
  383.          InverseVideo;
  384.          Readln(s);
  385.       End;
  386. End;
  387.  
  388. Procedure Set_Center;
  389.  
  390. begin
  391.    Clean;
  392.    InverseVideo;
  393.    Gotoxy(24,1);
  394.    Write('Centering title (y/n) ? :');
  395.    InverseVideo;
  396.    Readln(ce);
  397.    Clean;
  398.    InverseVideo;
  399.    Gotoxy(24,1);
  400.    Write('Centering factor :');
  401.    InverseVideo;
  402.    Readln(cf);
  403. End;
  404.  
  405. Procedure TxStyle;
  406.  
  407. Begin
  408.    Clean;
  409.    InverseVideo;
  410.    Gotoxy(24,1);
  411.    Write('Text style:');
  412.    InverseVideo;
  413.    Readln(XStyle);
  414.    If (xStyle='a') Or (xStyle='A') Then TST:=$00;
  415.    If (xStyle='b') Or (xStyle='B') Then TST:=$01;
  416.    If (xStyle='c') Or (xStyle='C') Then TST:=$02;
  417.    If (xStyle='d') Or (xStyle='D') Then TST:=$04;
  418.    If (xStyle='e') Or (xStyle='E') Then TST:=$08;
  419.    If (xStyle='f') Or (xStyle='F') Then TST:=$10;
  420.    If (xStyle='g') Or (xStyle='G') Then TST:=$20;
  421. End;
  422.  
  423. Procedure TiStyle;
  424.  
  425. Begin
  426.    Clean;
  427.    InverseVideo;
  428.    Gotoxy(24,1);
  429.    Write('Title style:');
  430.    InverseVideo;
  431.    Readln(Style);
  432.    If (Style='a') Or (Style='A') Then IST:=$00;
  433.    If (Style='b') Or (Style='B') Then IST:=$01;
  434.    If (Style='c') Or (Style='C') Then IST:=$02;
  435.    If (Style='d') Or (Style='D') Then IST:=$04;
  436.    If (Style='e') Or (Style='E') Then IST:=$08;
  437.    If (Style='f') Or (Style='F') Then IST:=$10;
  438.    If (Style='g') Or (Style='G') Then IST:=$20;
  439. End;
  440.  
  441. Procedure RFormat;
  442.  
  443. Var which       :1..5;
  444.     l           :1..128;
  445.  
  446. Begin
  447.    Clean;
  448.    InverseVideo;
  449.    Gotoxy(24,1);
  450.    Write('Refromat colomn #');
  451.    Readln(which);
  452.    If which>5 Then which:=5;
  453.    If which<1 Then which:=1;
  454.    Clean;
  455.    InverseVideo;
  456.    Gotoxy(24,1);
  457.    Write('Reformating Colomn #',which);
  458.    InverseVideo;
  459.    If which=1 Then
  460.       For l:=1 to C1 Do
  461.           If (Length(Data1[l]))>Cl1 Then
  462.              Delete(Data1[l],cl1,(Length(Data1[l])-cl1));
  463.    If which=2 Then
  464.       For l:=1 to C2 Do
  465.           If (Length(Data2[l]))>Cl2 Then
  466.              Delete(Data2[l],cl2,(Length(Data2[l])-cl2));
  467.    If which=3 Then
  468.       For l:=1 to C3 Do
  469.           If (Length(Data3[l]))>Cl3 Then
  470.              Delete(Data3[l],cl3,(Length(Data3[l])-cl3));
  471.    If which=4 Then
  472.       For l:=1 to C4 Do
  473.           If (Length(Data4[l]))>Cl4 Then
  474.              Delete(Data4[l],cl4,(Length(Data4[l])-cl4));
  475.    If which=5 Then
  476.       For l:=1 to C5 Do
  477.           If (Length(Data5[l]))>Cl5 Then
  478.              Delete(Data5[l],cl5,(Length(Data5[l])-cl5));
  479. End;
  480.  
  481. Procedure PPrint;
  482.  
  483. Var dum         :char;
  484.  
  485. Begin
  486.    TClean;
  487.    InverseVideo;
  488.    Gotoxy(24,1);
  489.    Write('If you want to print this paper, use the Alternate Help dump.');
  490.    InverseVideo;
  491.    CursOff;
  492.    Readln(dum);
  493.    TClean;
  494.    readln(dum);
  495. End;
  496.  
  497. Procedure Scale_Line;
  498.  
  499. Var yesno       :Char;
  500.  
  501. Begin
  502.    Clean;
  503.    Gotoxy(24,1);
  504.    Write('Scale line (y/n) ? :');
  505.    Readln(yesno);
  506.    If (yesno='y') or (yesno='Y') Then rs:=true
  507.    Else rs:=false;
  508. End;
  509.  
  510. Procedure Proc;
  511.  
  512. Begin
  513.    If (Command='QUIT') Or (Command='Quit') Or (Command='quit') Then
  514.       Run:=false;
  515.    If (Command='EXIT') Or (Command='Exit') Or (Command='exit') Then
  516.       Run:=false;
  517.    If (Command='BYE') Or (Command='Bye') Or (Command='bye') Then
  518.       Run:=false;
  519.    If (Command='TITLE') Or (Command='Title') Or (Command='title') Then
  520.       Set_Title;
  521.    If (Command='COLOMNS') Or (Command='Colomns') Or (Command='colomns') Then
  522.       Set_Colomns;
  523.    If (Command='ENTER') Or (Command='Enter') Or (Command='enter') Then
  524.       Enter_Data;
  525.    If (Command='TEXT') Or (Command='Text') Or (Command='text') Then
  526.       Set_text;
  527.    If (Command='SPACING') Or (Command='Spacing') Or (Command='spacing') Then
  528.       Set_s;
  529.    If (Command='CENTER') Or (Command='Center') Or (Command='center') Then
  530.       Set_center;
  531.    If (Command='TSTYLE') Or (Command='Tstyle') Or (Command='tstyle') Then
  532.       TiStyle;
  533.    If (Command='XSTYLE') Or (Command='Xstyle') Or (Command='xstyle') Then
  534.       TxStyle;
  535.    If (Command='FRAME') Or (Command='Frame') Or (Command='frame') Then
  536.       MF:=True;
  537.    If (Command='RFRAME') Or (Command='Rframe') Or (Command='rframe') Then
  538.       MRF:=True;
  539.    If (Command='TLINE') Or (Command='Tline') or (Command='tline') Then
  540.       LI:=True;
  541.    If (Command='CLINE') Or (Command='Cline') or (Command='cline') Then
  542.       CI:=True;
  543.    If (Command='GINIT') Or (Command='Ginit') or (Command='ginit') Then
  544.       GRInit;
  545.    If (Command='REFORMAT') Or (Command='Reformat') or (Command='reformat') Then
  546.       RFormat;
  547.    If (Command='PRINT') Or (Command='Print') or (Command='print') Then
  548.       PPRint;
  549.    If (Command='SLINE') Or (Command='Sline') or (Command='sline') Then
  550.       Scale_Line;
  551. End;
  552.  
  553. Procedure Out_Put;
  554.  
  555. Var i,j,k       :Integer;
  556.  
  557. Begin
  558.    Clrscr;
  559.    CursOff;
  560.    If Mrf=true Then
  561.       Frame_Round_Rect( 0,0,639,180 );
  562.    If title<>'@' Then
  563.       Begin
  564.          text_Style(IST);
  565.          text_Height(H);
  566.          If Ce='n' Then
  567.             Draw_String(5,((H)+3),title)
  568.          Else
  569.             Begin
  570.                i:=(((Length(title))*(H div cf)));
  571.                j:=(640-i) div 2;
  572.                Draw_String(J,((H)+3),title)
  573.             End;
  574.          If (Li=true) and (rs=false) Then
  575.             Line(5,(H+7),634,(H+7));
  576.          if (li=true) and (rs=false) Then
  577.             Line(5,(H+7),((Length(title))*8),(H+7));
  578.       End;
  579.    Text_Height(TH);
  580.    Text_Style(TST);
  581.    If flag[1]=true then
  582.       For i:=1 to C1 Do
  583.           Draw_String(5,((i*(th+s))+h+10),Data1[i]);
  584.    If flag[2]=true then
  585.       For i:=1 to C2 Do
  586.           Draw_String((Cl1*8+th),((i*(th+s))+h+10),Data2[i]);
  587.    If flag[3]=true then
  588.       For i:=1 to C3 Do
  589.           Draw_String(((Cl2+Cl1)*8+th),((i*(th+s))+h+10),Data3[i]);
  590.    If flag[4]=true then
  591.       For i:=1 to C4 Do
  592.           Draw_String(((Cl3+cl1+cl2)*8+th),((i*(th+s))+h+10),Data4[i]);
  593.    If flag[5]=true then
  594.       For i:=1 to C5 Do
  595.           Draw_String(((Cl3+Cl2+Cl1+Cl4)*8+th),((i*(th+s))+h+10),Data5[i]);
  596.    If Mf=true Then
  597.       Frame_Rect( 0,0,639,180 );
  598.    if ci=true Then
  599.       Begin
  600.          If Flag[2]=true then
  601.             Line((Cl1*8+(th div cf)-13),((2*H)+7),(Cl1*8+(th div cf)-13),(176));
  602.          If Flag[3]=true then
  603. Line(((Cl2+Cl1)*8+(th div cf)-13),((2*H)+7),(Cl2*8+(th div cf)-13),(176));
  604.          If Flag[4]=true then
  605. Line(((Cl2+Cl1+Cl3)*8+(th div cf)-13),((2*H)+7),(Cl3*8+(th div cf)-13),(176));
  606.          If Flag[5]=true then
  607. Line((640-(Cl4*8+(th div cf)-13)),((2*H)+7),(Cl4*8+(th div cf)-13),(176));
  608.       End;
  609. End;
  610.  
  611. Begin
  612.  If init_gem>=0 Then
  613.   Begin
  614.    Rs:=false;
  615.    Run:=true;
  616.    Init_Mouse;
  617.    Hide_Mouse;
  618.    title:='@';
  619.    Ce:='n';
  620.    Clrscr;
  621.    CursOn;
  622.    H:=8;
  623.    TH:=4;
  624.    s:=8;
  625.    TST:=$00;
  626.    IST:=$00;
  627.    Mf:=False;
  628.    LI:=False;
  629.    Ci:=False;
  630.    cf:=2;
  631.    Mrf:=false;
  632.    Xstyle:='A';
  633.    style:='A';
  634.    For t:=1 to 5 Do
  635.        Flag[t]:=false;
  636.        Dummy:=
  637.  Do_Alert('[1][The Card Maker V 1.1 | Programmed by Yaron Kidron][  OK  ]',0);
  638.    While run=true Do
  639.       Begin
  640.          Get_Command;
  641.          Proc;
  642.          Out_Put;
  643.       End;
  644.   End;
  645.  CursOff;
  646.  Show_Mouse;
  647.  Exit_Gem;
  648.  NormVideo;
  649. End.
  650.